home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / fp / ifp_unix.lzh / ifp / interp / forms.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-05-23  |  9.8 KB  |  414 lines
  1.  
  2. /****** forms.c *******************************************************/
  3. /**                                                                  **/
  4. /**                    University of Illinois                        **/
  5. /**                                                                  **/
  6. /**                Department of Computer Science                    **/
  7. /**                                                                  **/
  8. /**   Tool: IFP                         Version: 0.5                 **/
  9. /**                                                                  **/
  10. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  11. /**                                                                  **/
  12. /**   Revised by: Arch D. Robison       Date: July 28, 1986          **/
  13. /**                                                                  **/
  14. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  15. /**                            Prof. W. J. Kubitz                    **/
  16. /**                                                                  **/
  17. /**                                                                  **/
  18. /**------------------------------------------------------------------**/
  19. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  20. /**                       All Rights Reserved.                       **/
  21. /**********************************************************************/
  22.  
  23. #include "struct.h"
  24. #include "node.h"
  25. #include "umax.h"
  26. #include "stats.h"
  27. #include <stdio.h>
  28.  
  29. /*
  30.  * FF_Each
  31.  *
  32.  * Apply function F to each element of list InOut
  33.  *
  34.  * Input
  35.  *      InOut = list of elements to apply function
  36.  *      Funs = singleton list of function to be applied
  37.  *
  38.  * Output
  39.  *      InOut = result
  40.  */
  41. private FF_Each (InOut,Funs)
  42.    ObjectPtr InOut;
  43.    register ListPtr Funs;
  44.    {
  45.       register ListPtr P;
  46.  
  47.       switch (InOut->Tag) {
  48.      default:
  49.         FormError (InOut,ArgNotSeq,NODE_Each,Funs);
  50.         return;
  51.      case LIST:
  52.         CopyTop (&InOut->List);
  53.         break;
  54.       }
  55.       for (P = InOut->List; P!=NULL; P=P->Next) {
  56.      Apply (&P->Val,&Funs->Val);
  57.      if (P->Val.Tag == BOTTOM) {
  58.         RepTag (InOut,BOTTOM);      /* Error already reported */
  59.         return;
  60.      }
  61.       }
  62.    }
  63.  
  64.  
  65. /*
  66.  * FF_Filter
  67.  *
  68.  * Input
  69.  *      InOut = list of elements to apply predicate
  70.  *      Funs = singleton list of function to be applied
  71.  *
  72.  * Output
  73.  *      InOut = result - list of element for which predicate is true.
  74.  */
  75. private FF_Filter (InOut,Funs)
  76.    register ObjectPtr InOut;
  77.    register ListPtr Funs;
  78.    {
  79.       register ListPtr P;
  80.       register MetaPtr E;
  81.       ListPtr Result;
  82.       Object X;
  83.  
  84.       if (InOut->Tag != LIST)
  85.      FormError (InOut,ArgNotSeq,NODE_Filter,Funs);
  86.       else {
  87.      Result = NULL;
  88.      E = &Result;
  89.      for (P = InOut->List; P!=NULL; P=P->Next) {
  90.         CopyObject (&X,&P->Val);
  91.         Apply (&X,&Funs->Val);
  92.         if (X.Tag != BOOLEAN) {
  93.            FormError (&X,"non-boolean predicate",NODE_Filter,Funs);
  94.            RepTag (InOut,BOTTOM);
  95.            DelLPtr (Result);
  96.            return;
  97.         } else if (X.Bool) {   /* append element to result list */
  98.            NewList (E,1L);
  99.            CopyObject (&(*E)->Val,&P->Val);
  100.            E = &(*E)->Next;
  101.         }
  102.      }
  103.      DelLPtr (InOut->List);
  104.      InOut->List = Result;
  105.       }
  106.    }
  107.  
  108.  
  109. /*
  110.  * FF_Compose
  111.  *
  112.  * Function composition
  113.  *
  114.  * Input
  115.  *      InOut = object to apply composition
  116.  *      Funs = list of functions to compose in reverse order
  117.  *
  118.  * Output
  119.  *      InOut = result of composition
  120.  */
  121. private FF_Compose (InOut,Funs)
  122.    register ObjectPtr InOut;
  123.    register ListPtr Funs;
  124.    {
  125.       for (; Funs != NULL && InOut->Tag != BOTTOM; Funs = Funs->Next)
  126.      Apply (InOut,&Funs->Val);
  127.    }
  128.  
  129. /*
  130.  * FF_RInsert
  131.  *
  132.  * Function right insert
  133.  */
  134. private FF_RInsert (InOut,Funs)
  135.    register ObjectPtr InOut;
  136.    register ListPtr Funs;
  137.    {
  138.       ListPtr Terms;
  139.  
  140.       if (InOut->Tag != LIST)
  141.      FormError (InOut,ArgNotSeq,NODE_RInsert,Funs);
  142.       else if (InOut->List == NULL) 
  143.      FormError (InOut,"empty sequence",NODE_RInsert,Funs);
  144.       else {
  145.      F_Reverse (InOut); /* Copy top and reverse */
  146.      Terms = InOut->List->Next;
  147.      InOut->List->Next = NULL;
  148.      RepObject (InOut,&InOut->List->Val);
  149.      while (Terms != NULL) {
  150.         /* form pair and apply function */
  151.         NewList (&Terms->Next,1L);
  152.         Terms->Next->Val.Tag = InOut->Tag;
  153.         Terms->Next->Val.Data = InOut->Data;
  154.         InOut->Tag = LIST;
  155.         InOut->List = NULL;
  156.         Rot3 (&InOut->List,&Terms,&Terms->Next->Next);
  157.         Apply (InOut,&Funs->Val);
  158.         if (InOut->Tag == BOTTOM) {
  159.            DelLPtr (Terms);
  160.            break;
  161.         }
  162.      }
  163.       }
  164.    }
  165.  
  166. /*
  167.  * FF_C
  168.  *
  169.  * Constant function
  170.  */
  171. private FF_C (InOut,Funs)
  172.    ObjectPtr InOut;
  173.    register ListPtr Funs;
  174.    {
  175.       Stat (StatConstant (InOut));
  176.       if (Funs == NULL) 
  177.      FormError (InOut,"(constant bottom)",NODE_C,Funs);
  178.       else 
  179.      RepObject (InOut,&Funs->Val);
  180.    }
  181.  
  182. /*
  183.  * FF_Out
  184.  *
  185.  * Print debugging message
  186.  */
  187. private FF_Out (InOut,Funs)
  188.    ObjectPtr InOut;
  189.    register ListPtr Funs;
  190.    {
  191.       LineWait ();
  192.       OutObject (&Funs->Val),
  193.       printf (": "),
  194.       OutObject (InOut),
  195.       printf ("\n");
  196.       LineSignal ();
  197.    }
  198.  
  199.  
  200. #if FETCH 
  201. /*
  202.  * FF_Fetch
  203.  *
  204.  * Fetch form
  205.  */
  206. private FF_Fetch (InOut,Funs)
  207.    ObjectPtr InOut;
  208.    register ListPtr Funs;
  209.    {
  210.       register ListPtr P,Q,R;
  211.  
  212.       if (InOut->Tag != LIST)
  213.      FormError (InOut,ArgNotSeq,NODE_Fetch,Funs);
  214.       else {
  215.      R = NULL;
  216.  
  217.      for (P = InOut->List; P != NULL; P=P->Next)
  218.         if (P->Val.Tag != LIST || (Q=P->Val.List) == NULL ||
  219.         Q->Next == NULL || Q->Next->Next != NULL) {
  220.            FormError (InOut,"element not a pair",NODE_Fetch,Funs);
  221.            return;
  222.         } else
  223.            if (R == NULL && ObEqual (&Q->Val,&Funs->Val)) R = Q;
  224.  
  225.      if (R!=NULL) RepObject (InOut,&R->Next->Val);
  226.      else FormError (InOut,"key not found",NODE_Fetch,Funs);
  227.      return;
  228.  
  229.       }
  230.    }
  231. #endif FETCH
  232.  
  233.  
  234. /*
  235.  * FF_If
  236.  *
  237.  * Conditional p->f;g
  238.  *
  239.  * Input
  240.  *      InOut = object to apply conditional
  241.  *      Funs = <p f g>
  242.  *
  243.  * Output
  244.  *      InOut = result of conditional
  245.  */
  246. private FF_If (InOut,Funs)
  247.    ObjectPtr InOut;
  248.    ListPtr Funs;
  249.    {
  250.       Object P;
  251.  
  252.       CopyObject (&P,InOut);
  253.       Apply (&P,&Funs->Val);
  254.       if (P.Tag == BOOLEAN) 
  255.      Apply (InOut, & (P.Bool ? Funs : Funs->Next)->Next->Val);
  256.       else {
  257.      FormError (&P,"non-boolean predicate",NODE_If,Funs);
  258.      RepTag (InOut,BOTTOM);
  259.       } 
  260.    }
  261.  
  262. /*
  263.  * FF_Construct
  264.  *
  265.  * Function construction
  266.  *
  267.  * Input
  268.  *      InOut = object to apply construction
  269.  *      Funs = list of functions to construct
  270.  *
  271.  * Output
  272.  *      InOut = result
  273.  */
  274. private FF_Construct (InOut,Funs)
  275.    register ObjectPtr InOut;
  276.    ListPtr Funs;
  277.    {
  278.       register ListPtr P,F;
  279.       Stat (StatConstruct (Funs));
  280.       P = Repeat (InOut, ListLength (F = Funs));
  281.       if (SysError) return;
  282.       RepTag (InOut,LIST);
  283.       for (InOut->List = P; F != NULL; P=P->Next,F=F->Next) {
  284.      Apply (& P->Val,& F->Val);
  285.      if (P->Val.Tag == BOTTOM) {
  286.         RepTag (InOut,BOTTOM);     /* Error was already reported */
  287.         return;
  288.          }
  289.       }
  290.    }
  291.  
  292.  
  293. /*
  294.  * FF_Select
  295.  *
  296.  * Selector form (e.g. 1,2r)
  297.  *
  298.  * Input
  299.  *      InOut = object
  300.  *      Funs = index parameter list - positive values are left selectors
  301.  *                                    negative values are right selectors
  302.  */
  303. private FF_Select (InOut,Funs)
  304.    ObjectPtr InOut;
  305.    ListPtr Funs;
  306.    {
  307.       register ListPtr P;
  308.       register long N;
  309.       char *E;
  310.  
  311.       N = Funs->Val.Int; 
  312.       switch (InOut->Tag) {
  313.      default:
  314.         E = ArgNotSeq;
  315.         break;
  316.      case NODE:
  317.         NodeExpand (InOut);
  318.         /* drop through to case LIST */
  319.  
  320.      case LIST:
  321.         P = InOut->List;
  322.         if (N < 0) N += ListLength (P) + 1;
  323.         if (--N >= 0) {
  324.            for (; P!=NULL; P=P->Next)
  325.           if (--N < 0) {
  326.              RepObject (InOut,&P->Val);
  327.              return;
  328.           }
  329.            E = "index off right end";
  330.         } else
  331.            E = "index off left end";
  332.         break;
  333.       }
  334.       FormError (InOut,E,NODE_Sel,Funs);
  335.    }
  336.  
  337.  
  338. /*
  339.  * FF_While
  340.  *
  341.  * While P is true, apply F to X
  342.  *
  343.  * Input
  344.  *      InOut = X
  345.  *      Funs = pair <P F>
  346.  *
  347.  * Output
  348.  *      InOut = result
  349.  */
  350. private FF_While (InOut,Funs)
  351.    register ObjectPtr InOut;
  352.    register ListPtr Funs;
  353.    {
  354.       Object P;
  355.  
  356.       P.Tag = BOTTOM;
  357.       while (InOut->Tag!=BOTTOM) {
  358.      CopyObject (&P,InOut);       /* old P was element of {?,f,t} */
  359.      Apply (&P,&Funs->Val);
  360.      if (P.Tag != BOOLEAN) {
  361.         FormError (&P,"non-boolean predicate",NODE_While,Funs);
  362.         RepTag (InOut,BOTTOM);
  363.      } else
  364.         if (P.Bool) Apply (InOut,&Funs->Next->Val);
  365.         else break;
  366.       }
  367.    }
  368.  
  369.  
  370. #if XDEF
  371. extern FF_XDef();
  372. #endif
  373.  
  374.  
  375. /*
  376.  * FormTable
  377.  *
  378.  * These entries must be ordered to correspond with the #defines in "node.h".
  379.  */
  380. FormEntry FormTable[] = {
  381.    {NULL, "#",     OPDEF("constant" ,-1,FF_C        ,&TypeOBJECT_OBJECT),"#object"},
  382.    {NULL, "",      OPDEF("compose"  ,-1,FF_Compose  ,&TypeLIST),""},
  383.    {NULL, "[",     OPDEF("construct",-1,FF_Construct,&TypeLIST),"[...]"},
  384.    {NULL, "EACH",  OPDEF("each"     , 1,FF_Each     ,&TypeLIST_OBJECT),"EACH g END"},
  385. #if FETCH
  386.    {NULL, "^",     OPDEF("fetch"    , 1,FF_Fetch    ,&TypeLIST_OBJECT),"^c"},
  387. #endif
  388.    {NULL, "FILTER",OPDEF("filter"   , 1,FF_Filter   ,&TypeLIST_OBJECT),"FILTER p END"},
  389.    {NULL, "IF",    OPDEF("if"        , 3,FF_If        ,&TypeLIST),"IF p THEN g ELSE h END"},
  390.    {NULL, "INSERT",OPDEF("insertr"  , 1,FF_RInsert  ,&TypeLIST_OBJECT),"INSERT g END"},
  391.    {NULL, "@",     OPDEF("out"      , 1,FF_Out      ,&TypeOBJECT_OBJECT),"@message"},
  392.    {NULL, "",      OPDEF("select"   , 1,FF_Select   ,&TypeLIST_NUM),"digit"},
  393.    {NULL, "WHILE", OPDEF("while"    , 2,FF_While    ,&TypeLIST),"WHILE p DO g END"}
  394. #if XDEF
  395.   ,{NULL, "{",     OPDEF("xdef"     , 3,FF_XDef     ,&TypeLIST),"{...}"}
  396. #endif
  397. };
  398.  
  399. #undef F
  400.  
  401. void D_form ()
  402.    {
  403.       FormEntry *N;
  404.  
  405.       for (N=FormTable; N<ArrayEnd (FormTable); N++) 
  406.      N->FormNode = PrimDef (N->FormOp.OpPtr,
  407.                 N->FormOp.OpName,
  408.                 SysNode,
  409.                 N->FormOp.OpParam);
  410.    }
  411.  
  412. /******************************* end of forms.c *******************************/
  413.  
  414.